home *** CD-ROM | disk | FTP | other *** search
/ Skunkware 98 / Skunkware 98.iso / src / interp / perl5.005.tar.gz / perl5.005.tar / perl5.005 / x2p / find2perl.PL < prev    next >
Perl Script  |  1998-06-12  |  14KB  |  628 lines
  1. #!/usr/local/bin/perl
  2.  
  3. use Config;
  4. use File::Basename qw(&basename &dirname);
  5. use Cwd;
  6.  
  7. # List explicitly here the variables you want Configure to
  8. # generate.  Metaconfig only looks for shell variables, so you
  9. # have to mention them as if they were shell variables, not
  10. # %Config entries.  Thus you write
  11. #  $startperl
  12. # to ensure Configure will look for $Config{startperl}.
  13.  
  14. # This forces PL files to create target in same directory as PL file.
  15. # This is so that make depend always knows where to find PL derivatives.
  16. $origdir = cwd;
  17. chdir dirname($0);
  18. $file = basename($0, '.PL');
  19. $file .= '.com' if $^O eq 'VMS';
  20.  
  21. open OUT,">$file" or die "Can't create $file: $!";
  22.  
  23. print "Extracting $file (with variable substitutions)\n";
  24.  
  25. # In this section, perl variables will be expanded during extraction.
  26. # You can use $Config{...} to use Configure variables.
  27.  
  28. print OUT <<"!GROK!THIS!";
  29. $Config{startperl}
  30.     eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
  31.       if \$running_under_some_shell;
  32. \$startperl = "$Config{startperl}";
  33. \$perlpath = "$Config{perlpath}";
  34. !GROK!THIS!
  35.  
  36. # In the following, perl variables are not expanded during extraction.
  37.  
  38. print OUT <<'!NO!SUBS!';
  39.  
  40. # 
  41. # Modified September 26, 1993 to provide proper handling of years after 1999
  42. #   Tom Link <tml+@pitt.edu>
  43. #   University of Pittsburgh
  44. # 
  45. # Modified April 7, 1998 with nasty hacks to implement the troublesome -follow
  46. #  Billy Constantine <wdconsta@cs.adelaide.edu.au> <billy@smug.adelaide.edu.au>
  47. #  University of Adelaide, Adelaide, South Australia
  48. # 
  49.  
  50. while ($ARGV[0] =~ /^[^-!(]/) {
  51.     push(@roots, shift);
  52. }
  53. @roots = ('.') unless @roots;
  54. for (@roots) { $_ = "e($_); }
  55. $roots = join(',', @roots);
  56.  
  57. $indent = 1;
  58. $stat = 'lstat';
  59. $decl = '';
  60.  
  61. while (@ARGV) {
  62.     $_ = shift;
  63.     s/^-// || /^[()!]/ || die "Unrecognized switch: $_\n";
  64.     if ($_ eq '(') {
  65.     $out .= &tab . "(\n";
  66.     $indent++;
  67.     next;
  68.     }
  69.     elsif ($_ eq ')') {
  70.     $indent--;
  71.     $out .= &tab . ")";
  72.     }
  73.     elsif ($_ eq 'follow') {
  74.     $stat = 'stat';
  75.     $decl = '%already_seen = ();';
  76.     $out .= &tab . '(not $already_seen{"$dev,$ino"}) &&';
  77.     $out .= "\n" . &tab . '(($already_seen{"$dev,$ino"} = !(-d _)) || 1)';
  78.     }
  79.     elsif ($_ eq '!') {
  80.     $out .= &tab . "!";
  81.     next;
  82.     }
  83.     elsif ($_ eq 'name') {
  84.     $out .= &tab;
  85.     $pat = &fileglob_to_re(shift);
  86.     $out .= '/' . $pat . "/";
  87.     }
  88.     elsif ($_ eq 'perm') {
  89.     $onum = shift;
  90.     die "Malformed -perm argument: $onum\n" unless $onum =~ /^-?[0-7]+$/;
  91.     if ($onum =~ s/^-//) {
  92.         $onum = '0' . sprintf("%o", oct($onum) & 017777);    # s/b 07777 ?
  93.         $out .= &tab . "((\$mode & $onum) == $onum)";
  94.     }
  95.     else {
  96.         $onum = '0' . $onum unless $onum =~ /^0/;
  97.         $out .= &tab . "((\$mode & 0777) == $onum)";
  98.     }
  99.     }
  100.     elsif ($_ eq 'type') {
  101.     ($filetest = shift) =~ tr/s/S/;
  102.     $out .= &tab . "-$filetest _";
  103.     }
  104.     elsif ($_ eq 'print') {
  105.     $out .= &tab . 'print("$name\n")';
  106.     }
  107.     elsif ($_ eq 'print0') {
  108.     $out .= &tab . 'print("$name\0")';
  109.     }
  110.     elsif ($_ eq 'fstype') {
  111.     $out .= &tab;
  112.     $type = shift;
  113.     if ($type eq 'nfs')
  114.         { $out .= '($dev < 0)'; }
  115.     else
  116.         { $out .= '($dev >= 0)'; }
  117.     }
  118.     elsif ($_ eq 'user') {
  119.     $uname = shift;
  120.     $out .= &tab . "(\$uid == \$uid{'$uname'})";
  121.     $inituser++;
  122.     }
  123.     elsif ($_ eq 'group') {
  124.     $gname = shift;
  125.     $out .= &tab . "(\$gid == \$gid{'$gname'})";
  126.     $initgroup++;
  127.     }
  128.     elsif ($_ eq 'nouser') {
  129.     $out .= &tab . '!defined $uid{$uid}';
  130.     $inituser++;
  131.     }
  132.     elsif ($_ eq 'nogroup') {
  133.     $out .= &tab . '!defined $gid{$gid}';
  134.     $initgroup++;
  135.     }
  136.     elsif ($_ eq 'links') {
  137.     $out .= &tab . '($nlink ' . &n(shift);
  138.     }
  139.     elsif ($_ eq 'inum') {
  140.     $out .= &tab . '($ino ' . &n(shift);
  141.     }
  142.     elsif ($_ eq 'size') {
  143.     $out .= &tab . '(int(((-s _) + 511) / 512) ' . &n(shift);
  144.     }
  145.     elsif ($_ eq 'atime') {
  146.     $out .= &tab . '(int(-A _) ' . &n(shift);
  147.     }
  148.     elsif ($_ eq 'mtime') {
  149.     $out .= &tab . '(int(-M _) ' . &n(shift);
  150.     }
  151.     elsif ($_ eq 'ctime') {
  152.     $out .= &tab . '(int(-C _) ' . &n(shift);
  153.     }
  154.     elsif ($_ eq 'exec') {
  155.     for (@cmd = (); @ARGV && $ARGV[0] ne ';'; push(@cmd,shift)) { }
  156.     shift;
  157.     $_ = "@cmd";
  158.     if (m#^(/bin/)?rm -f {}$#) {
  159.         if (!@ARGV) {
  160.         $out .= &tab . 'unlink($_)';
  161.         }
  162.         else {
  163.         $out .= &tab . '(unlink($_) || 1)';
  164.         }
  165.     }
  166.     elsif (m#^(/bin/)?rm {}$#) {
  167.         $out .= &tab . '(unlink($_) || warn "$name: $!\n")';
  168.     }
  169.     else {
  170.         for (@cmd) { s/'/\\'/g; }
  171.         $" = "','";
  172.         $out .= &tab . "&exec(0, '@cmd')";
  173.         $" = ' ';
  174.         $initexec++;
  175.     }
  176.     }
  177.     elsif ($_ eq 'ok') {
  178.     for (@cmd = (); @ARGV && $ARGV[0] ne ';'; push(@cmd,shift)) { }
  179.     shift;
  180.     for (@cmd) { s/'/\\'/g; }
  181.     $" = "','";
  182.     $out .= &tab . "&exec(1, '@cmd')";
  183.     $" = ' ';
  184.     $initexec++;
  185.     }
  186.     elsif ($_ eq 'prune') {
  187.     $out .= &tab . '($prune = 1)';
  188.     }
  189.     elsif ($_ eq 'xdev') {
  190.     $out .= &tab . '!($prune |= ($dev != $topdev))';
  191.     }
  192.     elsif ($_ eq 'newer') {
  193.     $out .= &tab;
  194.     $file = shift;
  195.     $newername = 'AGE_OF' . $file;
  196.     $newername =~ s/[^\w]/_/g;
  197.     $newername = "\$$newername";
  198.     $out .= "(-M _ < $newername)";
  199.     $initnewer .= "$newername = -M " . "e($file) . ";\n";
  200.     }
  201.     elsif ($_ eq 'eval') {
  202.     $prog = "e(shift);
  203.     $out .= &tab . "eval $prog";
  204.     }
  205.     elsif ($_ eq 'depth') {
  206.     $depth++;
  207.     next;
  208.     }
  209.     elsif ($_ eq 'ls') {
  210.     $out .= &tab . "&ls";
  211.     $initls++;
  212.     }
  213.     elsif ($_ eq 'tar') {
  214.     $out .= &tab;
  215.     die "-tar must have a filename argument\n" unless @ARGV;
  216.     $file = shift;
  217.     $fh = 'FH' . $file;
  218.     $fh =~ s/[^\w]/_/g;
  219.     $out .= "&tar($fh)";
  220.     $file = '>' . $file;
  221.     $initfile .= "open($fh, " . "e($file) .
  222.       qq{) || die "Can't open $fh: \$!\\n";\n};
  223.     $inittar++;
  224.     $flushall = "\n&tflushall;\n";
  225.     }
  226.     elsif (/^n?cpio$/) {
  227.     $depth++;
  228.     $out .= &tab;
  229.     die "-$_ must have a filename argument\n" unless @ARGV;
  230.     $file = shift;
  231.     $fh = 'FH' . $file;
  232.     $fh =~ s/[^\w]/_/g;
  233.     $out .= "&cpio('" . substr($_,0,1) . "', $fh)";
  234.     $file = '>' . $file;
  235.     $initfile .= "open($fh, " . "e($file) .
  236.       qq{) || die "Can't open $fh: \$!\\n";\n};
  237.     $initcpio++;
  238.     $flushall = "\n&flushall;\n";
  239.     }
  240.     else {
  241.     die "Unrecognized switch: -$_\n";
  242.     }
  243.     if (@ARGV) {
  244.     if ($ARGV[0] eq '-o') {
  245.         { local($statdone) = 1; $out .= "\n" . &tab . "||\n"; }
  246.         $statdone = 0 if $indent == 1 && $delayedstat;
  247.         $saw_or++;
  248.         shift;
  249.     }
  250.     else {
  251.         $out .= " &&" unless $ARGV[0] eq ')';
  252.         $out .= "\n";
  253.         shift if $ARGV[0] eq '-a';
  254.     }
  255.     }
  256. }
  257.  
  258. print <<"END";
  259. $startperl
  260.     eval 'exec $perlpath -S \$0 \${1+"\$@"}'
  261.     if \$running_under_some_shell;
  262.  
  263. END
  264.  
  265. if ($initls) {
  266.     print <<'END';
  267. @rwx = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
  268. @moname = (Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec);
  269.  
  270. END
  271. }
  272.  
  273. if ($inituser || $initls) {
  274.     print 'while (($name, $pw, $uid) = getpwent) {', "\n";
  275.     print '    $uid{$name} = $uid{$uid} = $uid;', "\n" if $inituser;
  276.     print '    $user{$uid} = $name unless $user{$uid};', "\n" if $initls;
  277.     print "}\n\n";
  278. }
  279.  
  280. if ($initgroup || $initls) {
  281.     print 'while (($name, $pw, $gid) = getgrent) {', "\n";
  282.     print '    $gid{$name} = $gid{$gid} = $gid;', "\n" if $initgroup;
  283.     print '    $group{$gid} = $name unless $group{$gid};', "\n" if $initls;
  284.     print "}\n\n";
  285. }
  286.  
  287. print $initnewer, "\n" if $initnewer;
  288.  
  289. print $initfile, "\n" if $initfile;
  290.  
  291. $find = $depth ? "finddepth" : "find";
  292. print <<"END";
  293. require "$find.pl";
  294.  
  295. # Traverse desired filesystems
  296.  
  297. $decl
  298. &$find($roots);
  299. $flushall
  300. exit;
  301. sub wanted {
  302. $out;
  303. }
  304.  
  305. END
  306.  
  307. if ($initexec) {
  308.     print <<'END';
  309. sub exec {
  310.     local($ok, @cmd) = @_;
  311.     foreach $word (@cmd) {
  312.     $word =~ s#{}#$name#g;
  313.     }
  314.     if ($ok) {
  315.     local($old) = select(STDOUT);
  316.     $| = 1;
  317.     print "@cmd";
  318.     select($old);
  319.     return 0 unless <STDIN> =~ /^y/;
  320.     }
  321.     chdir $cwd;        # sigh
  322.     system @cmd;
  323.     chdir $dir;
  324.     return !$?;
  325. }
  326.  
  327. END
  328. }
  329.  
  330. if ($initls) {
  331.     print <<"INTERP", <<'END';
  332. sub ls {
  333.     (\$dev,\$ino,\$mode,\$nlink,\$uid,\$gid,\$rdev,\$sizemm,
  334.       \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat\(_\);
  335. INTERP
  336.  
  337.     $pname = $name;
  338.  
  339.     if (defined $blocks) {
  340.     $blocks = int(($blocks + 1) / 2);
  341.     }
  342.     else {
  343.     $blocks = int(($size + 1023) / 1024);
  344.     }
  345.  
  346.     if    (-f _) { $perms = '-'; }
  347.     elsif (-d _) { $perms = 'd'; }
  348.     elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
  349.     elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
  350.     elsif (-p _) { $perms = 'p'; }
  351.     elsif (-S _) { $perms = 's'; }
  352.     else         { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
  353.  
  354.     $tmpmode = $mode;
  355.     $tmp = $rwx[$tmpmode & 7];
  356.     $tmpmode >>= 3;
  357.     $tmp = $rwx[$tmpmode & 7] . $tmp;
  358.     $tmpmode >>= 3;
  359.     $tmp = $rwx[$tmpmode & 7] . $tmp;
  360.     substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
  361.     substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
  362.     substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
  363.     $perms .= $tmp;
  364.  
  365.     $user = $user{$uid} || $uid;
  366.     $group = $group{$gid} || $gid;
  367.  
  368.     ($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
  369.     $moname = $moname[$mon];
  370.     if (-M _ > 365.25 / 2) {
  371.     $timeyear = $year + 1900;
  372.     }
  373.     else {
  374.     $timeyear = sprintf("%02d:%02d", $hour, $min);
  375.     }
  376.  
  377.     printf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
  378.         $ino,
  379.          $blocks,
  380.               $perms,
  381.                 $nlink,
  382.                 $user,
  383.                      $group,
  384.                       $sizemm,
  385.                           $moname,
  386.                          $mday,
  387.                              $timeyear,
  388.                              $pname;
  389.     1;
  390. }
  391.  
  392. sub sizemm {
  393.     sprintf("%3d, %3d", ($rdev >> 8) & 255, $rdev & 255);
  394. }
  395.  
  396. END
  397. }
  398.  
  399. if ($initcpio) {
  400. print <<'START', <<"INTERP", <<'END';
  401. sub cpio {
  402.     local($nc,$fh) = @_;
  403.     local($text);
  404.  
  405.     if ($name eq 'TRAILER!!!') {
  406.     $text = '';
  407.     $size = 0;
  408.     }
  409.     else {
  410. START
  411.     (\$dev,\$ino,\$mode,\$nlink,\$uid,\$gid,\$rdev,\$size,
  412.       \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat\(_\);
  413. INTERP
  414.     if (-f _) {
  415.         open(IN, "./$_\0") || do {
  416.         warn "Couldn't open $name: $!\n";
  417.         return;
  418.         };
  419.     }
  420.     else {
  421.         $text = readlink($_);
  422.         $size = 0 unless defined $text;
  423.     }
  424.     }
  425.  
  426.     ($nm = $name) =~ s#^\./##;
  427.     $nc{$fh} = $nc;
  428.     if ($nc eq 'n') {
  429.     $cpout{$fh} .=
  430.       sprintf("%06o%06o%06o%06o%06o%06o%06o%06o%011lo%06o%011lo%s\0",
  431.         070707,
  432.         $dev & 0777777,
  433.         $ino & 0777777,
  434.         $mode & 0777777,
  435.         $uid & 0777777,
  436.         $gid & 0777777,
  437.         $nlink & 0777777,
  438.         $rdev & 0177777,
  439.         $mtime,
  440.         length($nm)+1,
  441.         $size,
  442.         $nm);
  443.     }
  444.     else {
  445.     $cpout{$fh} .= "\0" if length($cpout{$fh}) & 1;
  446.     $cpout{$fh} .= pack("SSSSSSSSLSLa*",
  447.         070707, $dev, $ino, $mode, $uid, $gid, $nlink, $rdev, $mtime,
  448.         length($nm)+1, $size, $nm . (length($nm) & 1 ? "\0" : "\0\0"));
  449.     }
  450.     if ($text ne '') {
  451.     $cpout{$fh} .= $text;
  452.     }
  453.     elsif ($size) {
  454.     &flush($fh) while ($l = length($cpout{$fh})) >= 5120;
  455.     while (sysread(IN, $cpout{$fh}, 5120 - $l, $l)) {
  456.         &flush($fh);
  457.         $l = length($cpout{$fh});
  458.     }
  459.     }
  460.     close IN;
  461. }
  462.  
  463. sub flush {
  464.     local($fh) = @_;
  465.  
  466.     while (length($cpout{$fh}) >= 5120) {
  467.     syswrite($fh,$cpout{$fh},5120);
  468.     ++$blocks{$fh};
  469.     substr($cpout{$fh}, 0, 5120) = '';
  470.     }
  471. }
  472.  
  473. sub flushall {
  474.     $name = 'TRAILER!!!';
  475.     foreach $fh (keys %cpout) {
  476.     &cpio($nc{$fh},$fh);
  477.     $cpout{$fh} .= "0" x (5120 - length($cpout{$fh}));
  478.     &flush($fh);
  479.     print $blocks{$fh} * 10, " blocks\n";
  480.     }
  481. }
  482.  
  483. END
  484. }
  485.  
  486. if ($inittar) {
  487. print <<'START', <<"INTERP", <<'END';
  488. sub tar {
  489.     local($fh) = @_;
  490.     local($linkname,$header,$l,$slop);
  491.     local($linkflag) = "\0";
  492.  
  493. START
  494.     (\$dev,\$ino,\$mode,\$nlink,\$uid,\$gid,\$rdev,\$size,
  495.       \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat\(_\);
  496. INTERP
  497.     $nm = $name;
  498.     if ($nlink > 1) {
  499.     if ($linkname = $linkseen{$fh,$dev,$ino}) {
  500.         $linkflag = 1;
  501.     }
  502.     else {
  503.         $linkseen{$fh,$dev,$ino} = $nm;
  504.     }
  505.     }
  506.     if (-f _) {
  507.     open(IN, "./$_\0") || do {
  508.         warn "Couldn't open $name: $!\n";
  509.         return;
  510.     };
  511.     $size = 0 if $linkflag ne "\0";
  512.     }
  513.     else {
  514.     $linkname = readlink($_);
  515.     $linkflag = 2 if defined $linkname;
  516.     $nm .= '/' if -d _;
  517.     $size = 0;
  518.     }
  519.  
  520.     $header = pack("a100a8a8a8a12a12a8a1a100",
  521.     $nm,
  522.     sprintf("%6o ", $mode & 0777),
  523.     sprintf("%6o ", $uid & 0777777),
  524.     sprintf("%6o ", $gid & 0777777),
  525.     sprintf("%11o ", $size),
  526.     sprintf("%11o ", $mtime),
  527.     "        ",
  528.     $linkflag,
  529.     $linkname);
  530.     $l = length($header) % 512;
  531.     substr($header, 148, 6) = sprintf("%6o", unpack("%16C*", $header));
  532.     substr($header, 154, 1) = "\0";  # blech
  533.     $tarout{$fh} .= $header;
  534.     $tarout{$fh} .= "\0" x (512 - $l) if $l;
  535.     if ($size) {
  536.     &tflush($fh) while ($l = length($tarout{$fh})) >= 10240;
  537.     while (sysread(IN, $tarout{$fh}, 10240 - $l, $l)) {
  538.         $slop = length($tarout{$fh}) % 512;
  539.         $tarout{$fh} .= "\0" x (512 - $slop) if $slop;
  540.         &tflush($fh);
  541.         $l = length($tarout{$fh});
  542.     }
  543.     }
  544.     close IN;
  545. }
  546.  
  547. sub tflush {
  548.     local($fh) = @_;
  549.  
  550.     while (length($tarout{$fh}) >= 10240) {
  551.     syswrite($fh,$tarout{$fh},10240);
  552.     ++$blocks{$fh};
  553.     substr($tarout{$fh}, 0, 10240) = '';
  554.     }
  555. }
  556.  
  557. sub tflushall {
  558.     local($len);
  559.  
  560.     foreach $fh (keys %tarout) {
  561.     $len = 10240 - length($tarout{$fh});
  562.     $len += 10240 if $len < 1024;
  563.     $tarout{$fh} .= "\0" x $len;
  564.     &tflush($fh);
  565.     }
  566. }
  567.  
  568. END
  569. }
  570.  
  571. exit;
  572.  
  573. ############################################################################
  574.  
  575. sub tab {
  576.     local($tabstring);
  577.  
  578.     $tabstring = "\t" x ($indent / 2) . ' ' x ($indent % 2 * 4);
  579.     if (!$statdone) {
  580.     if ($_ =~ /^(name|print|prune|exec|ok|\(|\))/) {
  581.         $delayedstat++;
  582.     }
  583.     else {
  584.         if ($saw_or) {
  585.         $tabstring .= <<"ENDOFSTAT" . $tabstring;
  586. (\$nlink || ((\$dev,\$ino,\$mode,\$nlink,\$uid,\$gid) = $stat\(\$_\))) &&
  587. ENDOFSTAT
  588.         }
  589.         else {
  590.         $tabstring .= <<"ENDOFSTAT" . $tabstring;
  591. ((\$dev,\$ino,\$mode,\$nlink,\$uid,\$gid) = $stat\(\$_\)) &&
  592. ENDOFSTAT
  593.         }
  594.         $statdone = 1;
  595.     }
  596.     }
  597.     $tabstring =~ s/^\s+/ / if $out =~ /!$/;
  598.     $tabstring;
  599. }
  600.  
  601. sub fileglob_to_re {
  602.     local($tmp) = @_;
  603.  
  604.     $tmp =~ s#([./^\$()])#\\$1#g;
  605.     $tmp =~ s/([?*])/.$1/g;
  606.     "^$tmp\$";
  607. }
  608.  
  609. sub n {
  610.     local($n) = @_;
  611.  
  612.     $n =~ s/^-/< / || $n =~ s/^\+/> / || $n =~ s/^/== /;
  613.     $n =~ s/ 0*(\d)/ $1/;
  614.     $n . ')';
  615. }
  616.  
  617. sub quote {
  618.     local($string) = @_;
  619.     $string =~ s/'/\\'/;
  620.     "'$string'";
  621. }
  622. !NO!SUBS!
  623.  
  624. close OUT or die "Can't close $file: $!";
  625. chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
  626. exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
  627. chdir $origdir;
  628.